Probleme mit 2fachem Template-Loop - #129831 (Perl/CGI)

pktm
2009-12-30 15:12
User since
2003-08-07
2921 Artikel
BenutzerIn
Ich wollte SQLite schon immer einmal ausprobieren, hier ist das Resultat.
Eventuell findet der Threadersteller das ein oder andere nützliche Code-Fragment hinsichtlich seiner Problemstellung.
Code: (dl )
#!/Perl/bin/perl

package CatcherInTheRye;

use strict;
use warnings;
use base qw/CGI::Application/;

use CGI::Application::Plugin::Forward;
use CGI::Application::Plugin::Redirect;
use CGI::Application::Plugin::HTCompiled;
use CGI::Application::Plugin::Session;
use CGI::Application::Plugin::MessageStack;
use CGI::Application::Plugin::DBH (qw/dbh dbh_config/);

use Data::Dumper qw/Dumper/;

our $VERSION = 0.1;

=head1 NAME

CatcherInTheRye - a boring book

=head1 DESCRIPTION

Beispiel für die Verwendung von SQLite. create_db erzeugt eine Datenbank mit
Testdaten, explore_db zeigt die Testdaten an. Beides kann über den
start-runmode start erreicht werden.


=head1 METHODS

=cut

=head2 cgiapp_init()

Open database connection, setup config files, etc.

=cut

sub cgiapp_init {
	my $self = shift;
	
	# -- use the same args as DBI->connect();
	my $db_cfg = {
		dsn => 'dbi:SQLite:dbname=test.db',
		username => '',
		password => '',
		attributes => {
			RaiseError     => 1,
			AutoCommit     => 1,
			sqlite_unicode => 1,
		},
	};
    $self->dbh_config($db_cfg->{dsn}, $db_cfg->{username}, $db_cfg->{password},
		$db_cfg->{attributes});
	
	
	# -- configure CAP::MessageStack to auto clear messages
	$self->capms_config(
		-automatic_clearing            => 1,
	);
	
} # /cgiapp_init




=head2 setup()

Defined runmodes, etc.

=cut

sub setup {
	my $self = shift;
	
	$self->start_mode('start');
	$self->run_modes([qw/
		start
		create_db
		explore_db
	/]);
	
} # /setup




=head2 start()

Zeige ein Formular, mit dem die Datenbank erstellt werden kann + den Link zur
Anzeige der Datenbank-Daten. Die Datenbank sollte wahrschienlich besser erzeugt
werden, *bevor* deren Inhalt angezeigt wird.

=cut

sub start {
	my $self 	= shift;
	
	my $tmpl = q~
<html>
	<head>
		<meta http-equiv="content-type" content="text/html; charset=utf-8" />
		<link rel="shortcut icon" type="image/ico" href="/favicon.ico" />
		
		<title>SQLite-Test</title>
	</head>
	<body>

		<h1>Test von SQLite</h1>

	<!-- TMPL_LOOP NAME="CAP_Messages" -->
		<div class="<!-- TMPL_VAR NAME="classification" -->">
		<!-- TMPL_VAR NAME="message" -->
		</div>
	<!-- /TMPL_LOOP -->

		<form action="<TMPL_VAR c.query.url>" method="POST">
			<input type="hidden" name="rm" value="create_db" />
			<input type="submit" value="create db" />
		</form>

		<a href="<TMPL_VAR c.query.url>?rm=explore_db">explore db</a>

	</body>
</html>
	~;
	my $t = $self->load_tmpl(\$tmpl);
	return $t->output();
} # /start




=head2 create_db()

Create a SQLite databse and fill in some values.

=cut

sub create_db {
	my $self = shift;
	
	my $dbh = $self->dbh();

	$dbh->do(q{DROP TABLE If EXISTS persons});
	$dbh->do(q{
		CREATE TABLE persons (
			id          INTEGER PRIMARY KEY AUTOINCREMENT,
			first_name  VARCHAR(255),
			last_name   VARCHAR(255)
		)
	});

	$dbh->do(q{DROP TABLE If EXISTS groups});
	$dbh->do(q{
		CREATE TABLE groups (
			id     INTEGER PRIMARY KEY AUTOINCREMENT,
			title  VARCHAR(255)
		)
	});
	
	$dbh->do(q{DROP TABLE If EXISTS persons2groups});
	$dbh->do(q{
		CREATE TABLE persons2groups (
			id         INTEGER PRIMARY KEY AUTOINCREMENT,
			person_id  INTEGER,
			group_id   INTEGER
		)
	});
	
	my $grp_stmt = $dbh->prepare(q{INSERT INTO groups (title) VALUES (?)});
	for my $data ( 'admin', 'user', 'guest' ) {
		$grp_stmt->execute($data);
	}
	
	my $usr_stmt = $dbh->prepare(q{
		INSERT INTO persons (first_name, last_name) VALUES (?, ?)});
	for my $data ( ['mr.','admin'], ['mäh','maz'], ['john','smith'] ) {
		$usr_stmt->execute(@{$data}[0,1]);
	}
	
	my $usr_grp_stmt = $dbh->prepare(q{
		INSERT INTO persons2groups (person_id, group_id) VALUES (?, ?)});
	for my $data ( [1,1], [1,2], [1,3], [2,3], [3,2] ) {
		$usr_grp_stmt->execute(@{$data}[0,1]);
	}

	$self->push_message(
		-scope          => 'start',
		-message        => localtime() . ' - Your db has been created',
		-classification => 'INFO',
    );
	
	return $self->redirect( $self->query->url()  . '?rm=start' );
} # /create_db




=head2 explore_db()

Display some data.

=cut

sub explore_db {
	my $self = shift;
	
	my $dbh = $self->dbh();
	my $sth = $dbh->prepare(q{SELECT * FROM persons})
		or die('error preparing: ' . DBI->errstr());
	my $rv = $sth->execute() or die('error executing: ' . DBI->errstr());
	
	my @all_persons_loop = ();
	
	while( my $user_data = $sth->fetchrow_hashref ) {
		my $user_id = $user_data->{id};
		
		my %data_of_one_user = (
			first_name => $user_data->{first_name},
			last_name => $user_data->{last_name},
			groups => [], # we don't have those yet
		);
		
		# -- now get the groups
		my $grp_sth = $dbh->prepare(q{
			SELECT g.title
			FROM persons2groups p2g
			LEFT JOIN groups g ON g.id = p2g.group_id
			WHERE person_id = ?
		}) or die('error preparing: ' . DBI->errstr());
		my $grp_rv = $grp_sth->execute($user_id)
			or die('error executing: ' . DBI->errstr());
		
		while( my $grp_data = $grp_sth->fetchrow_arrayref() ) {
			# -- Bitte fragen, wenn das unklar ist:
			push @{$data_of_one_user{'groups'}}, { title => $grp_data->[0] };
		}
		
		push @all_persons_loop, \%data_of_one_user;
	}


	my $tmpl = q~
<html>
	<body>
	
		<a href="<TMPL_VAR c.query.url>">zurück</a>
		<ul>
		<TMPL_LOOP all_persons>
			<li><TMPL_VAR first_name> <TMPL_VAR last_name>,
				Mitglied in folgenden Gruppen:<br />
				<ul>
				<TMPL_LOOP groups>
					<li><TMPL_VAR title></li>
				</TMPL_LOOP>
				</ul>
			</li>
		</TMPL_LOOP>
		
		<hr />
		<p>So sieht die Datenstruktur aus:<br />
		<pre><TMPL_VAR dump></pre>
		</p>
		
		</ul>
	</body>
</html>
	~;
	my $t = $self->load_tmpl(\$tmpl);
	$t->param('dump' => Dumper(\@all_persons_loop));
	$t->param('all_persons' => \@all_persons_loop);
	return $t->output();
} # /explore_db

=head1 LICENSE

This library is free software; you can redistribute it and/or modify it under
the same terms as Perl itself, either Perl version 5.8.8 or, at your option,
any later version of Perl 5 you may have available.

=cut

1;

use strict;
use warnings;
use FindBin qw/$Bin/;

my $app = CatcherInTheRye->new();
$app->run();
http://www.intergastro-service.de (mein erstes CMS :) )